home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / wind.scm < prev    next >
Text File  |  1995-10-13  |  3KB  |  101 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file wind.scm.  (Rhymes with "find," not "pinned.")
  6.  
  7. ;;;; Dynamic-wind
  8.  
  9.  
  10. ; This is a version of dynamic-wind that tries to do "the right thing"
  11. ; in the presence of multiple threads of control.
  12. ; This definition of "the right thing" is due to Pavel Curtis, and is
  13. ; the one used in Scheme Xerox.  It is very different from what you will
  14. ; find in, say, MIT Scheme.
  15. ;
  16. ; When we want to go to a new target state (e.g. on invoking a
  17. ; continuation), we ascend to the nearest common ancestor of the
  18. ; current state and the target state, executing the "out" (or
  19. ; "unwind") thunk for each state on the way; then we climb back down
  20. ; to the target state executing the "in" thunk for each state.  Unlike
  21. ; the Hanson/Lamping algorithm, the tree of states is not altered in
  22. ; any way.
  23. ;
  24. ; Each thread starts out in the root state, but continuations capture
  25. ; the state where they're created.
  26.  
  27.  
  28. ; Dynamic-wind
  29.  
  30. (define (dynamic-wind in body out)
  31.   (in)
  32.   (let ((results (let-dynamic-point (let ((here (get-dynamic-point)))
  33.                       (make-point (+ (point-depth here) 1)
  34.                           in
  35.                           out
  36.                           (get-dynamic-env)
  37.                           here))
  38.            (lambda ()
  39.              (call-with-values body list)))))
  40.     (out)
  41.     (apply values results)))
  42.  
  43. ; call-with-current-continuation
  44.  
  45. (define (call-with-current-continuation proc)
  46.   (primitive-cwcc
  47.     (lambda (cont)
  48.       (let ((env (get-dynamic-env)))
  49.     (proc (continuation->procedure cont env)))))) ;don't close over proc
  50.  
  51. (define (continuation->procedure cont env)
  52.   (lambda results
  53.     (travel-to-point! (get-dynamic-point) (env-dynamic-point env))
  54.     (set-dynamic-env! env)
  55.     (with-continuation cont
  56.       (lambda () (apply values results)))))
  57.  
  58. ; Point in state space = <depth, in, out, dynamic-env, parent>
  59. ; dynamic-env = dynamic environment for execution of the in and out thunks
  60.  
  61. (define-record-type point :point
  62.   (make-point depth in out dynamic-env parent)
  63.   (depth point-depth)
  64.   (in point-in)
  65.   (out point-out)
  66.   (dynamic-env point-dynamic-env)
  67.   (parent point-parent))
  68.  
  69. (define root-point            ;Shared among all state spaces
  70.   (make-point 0
  71.           (lambda () (error "winding in to root!"))
  72.           (lambda () (error "winding out of root!"))
  73.           '() ;(empty-dynamic-env)    ;Should never be seen
  74.           #f))
  75.  
  76. (define $dynamic-point (make-fluid root-point))
  77. (define (get-dynamic-point) (fluid $dynamic-point))
  78. (define (env-dynamic-point env)
  79.   (fluid-lookup env $dynamic-point))
  80. (define (let-dynamic-point point thunk)
  81.   (let-fluid $dynamic-point point thunk))
  82.  
  83. ; Go to a point in state space.  This involves running out-thunks from
  84. ; the current point out to its common ancestor with the target, and
  85. ; then running in-thunks from the ancestor to the target.
  86.  
  87. (define (travel-to-point! here target)
  88.   (cond ((eq? here target) 'done)
  89.     ((< (point-depth here)
  90.         (point-depth target))
  91.      (travel-to-point! here (point-parent target))
  92.      (set-dynamic-env! (point-dynamic-env target))
  93.      ((point-in target)))
  94.     (else
  95.      (set-dynamic-env! (point-dynamic-env here))
  96.      ((point-out here))
  97.      (travel-to-point! (point-parent here) target))))
  98.  
  99.  
  100. ; (put 'let-dynamic-point 'scheme-indent-hook 1)
  101.